home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / tests / focus.test < prev    next >
Encoding:
Text File  |  1995-03-28  |  12.7 KB  |  506 lines
  1. # This file is a Tcl script to test out the "focus" command and the
  2. # other procedures in the file tkFocus.c.  It is organized in the
  3. # standard fashion for Tcl tests.
  4. #
  5. # Copyright (c) 1994 Sun Microsystems, Inc.
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. #
  10. # @(#) focus.test 1.10 95/03/18 15:52:17
  11.  
  12. if {[info procs test] != "test"} {
  13.     source defs
  14. }
  15.  
  16. if {[info commands testevent] != ""} {
  17.     set gotTestEvent 1
  18. } else {
  19.     set gotTestEvent 0
  20. }
  21.  
  22. eval destroy [winfo children .]
  23. wm geometry . {}
  24. raise .
  25.  
  26. button .b -text .b -relief raised -bd 2
  27. pack .b
  28.  
  29. proc focusSetup {} {
  30.     catch {destroy .t}
  31.     toplevel .t
  32.     wm geom .t +0+0
  33.     foreach i {b1 b2 b3 b4} {
  34.     button .t.$i -text .t.$i -relief raised -bd 2
  35.     pack .t.$i
  36.     }
  37. }
  38. proc focusSetupAlt {} {
  39.     global env
  40.     catch {destroy .alt}
  41.     toplevel .alt -screen $env(TK_ALT_DISPLAY)
  42.     wm withdraw .alt
  43.     foreach i {a b c d} {
  44.     button .alt.$i -text .alt.$i -relief raised -bd 2
  45.     pack .alt.$i
  46.     }
  47. }
  48.  
  49. # The following procedure ensures that there is no input focus
  50. # in this application.  It does it by arranging for another
  51. # application to grab the focus.  The "after" and "update" stuff
  52. # is needed to wait long enough for pending actions to get through
  53. # the X server and possibly also the window manager.
  54.  
  55. setupbg
  56. proc focusClear {} {
  57.     global x;
  58.     after 200 {set x 1}
  59.     tkwait variable x
  60.     dobg {focus -force .; update}
  61.     update
  62. }
  63.  
  64. focusSetup
  65. set altDisplay [info exists env(TK_ALT_DISPLAY)]
  66. if $altDisplay {
  67.     focusSetupAlt
  68. }
  69. update
  70.  
  71. bind all <FocusIn> {
  72.     append focusInfo "in %W %d\n"
  73. }
  74. bind all <FocusOut> {
  75.     append focusInfo "out %W %d\n"
  76. }
  77. bind all <KeyPress> {
  78.     append focusInfo "press %W %K"
  79. }
  80.  
  81. focus .t
  82. focusSetup
  83. update
  84. test focus-1.1 {Tk_FocusCmd procedure} {
  85.     focusClear
  86.     focus
  87. } {}
  88. if $altDisplay {
  89.     test focus-1.2 {Tk_FocusCmd procedure} {
  90.     focus .alt.b
  91.     focus
  92.     } {}
  93. }
  94. test focus-1.3 {Tk_FocusCmd procedure} {
  95.     focusClear
  96.     focus .t.b3
  97.     focus
  98. } {}
  99. test focus-1.4 {Tk_FocusCmd procedure} {
  100.     list [catch {focus ""} msg] $msg
  101. } {0 {}}
  102. test focus-1.5 {Tk_FocusCmd procedure} {
  103.     focusClear
  104.     focus -force .t
  105.     focus .t.b3
  106.     focus
  107. } {.t.b3}
  108. test focus-1.6 {Tk_FocusCmd procedure} {
  109.     list [catch {focus .gorp} msg] $msg
  110. } {1 {bad window path name ".gorp"}}
  111. test focus-1.7 {Tk_FocusCmd procedure} {
  112.     list [catch {focus .gorp a} msg] $msg
  113. } {1 {bad option ".gorp": must be -displayof, -force, or -lastfor}}
  114. test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} {
  115.     toplevel .t2
  116.     wm geom .t2 +10+10
  117.     frame .t2.f -width 200 -height 100 -bd 2 -relief raised
  118.     frame .t2.f2 -width 200 -height 100 -bd 2 -relief raised
  119.     pack .t2.f .t2.f2
  120.     bind .t2.f <Destroy> {focus .t2.f}
  121.     bind .t2.f2 <Destroy> {focus .t2}
  122.     focus -force .t2.f2
  123.     tkwait visibility .t2
  124.     update
  125.     set x [focus]
  126.     destroy .t2.f2
  127.     lappend x [focus]
  128.     destroy .t2.f
  129.     lappend x [focus]
  130.     destroy .t2
  131.     set x
  132. } {.t2.f2 .t2 .t2}
  133. test focus-1.9 {Tk_FocusCmd procedure, -displayof option} {
  134.     list [catch {focus -displayof} msg] $msg
  135. } {1 {wrong # args: should be "focus -displayof window"}}
  136. test focus-1.10 {Tk_FocusCmd procedure, -displayof option} {
  137.     list [catch {focus -displayof a b} msg] $msg
  138. } {1 {wrong # args: should be "focus -displayof window"}}
  139. test focus-1.11 {Tk_FocusCmd procedure, -displayof option} {
  140.     list [catch {focus -displayof .lousy} msg] $msg
  141. } {1 {bad window path name ".lousy"}}
  142. test focus-1.12 {Tk_FocusCmd procedure, -displayof option} {
  143.     focusClear
  144.     focus .t
  145.     focus -displayof .t.b3
  146. } {}
  147. test focus-1.13 {Tk_FocusCmd procedure, -displayof option} {
  148.     focusClear
  149.     focus -force .t
  150.     focus -displayof .t.b3
  151. } {.t}
  152. if $altDisplay {
  153.     test focus-1.14 {Tk_FocusCmd procedure, -displayof option} {
  154.     focus -force .alt.c
  155.     focus -displayof .alt
  156.     } {.alt.c}
  157. }
  158. test focus-1.15 {Tk_FocusCmd procedure, -force option} {
  159.     list [catch {focus -force} msg] $msg
  160. } {1 {wrong # args: should be "focus -force window"}}
  161. test focus-1.16 {Tk_FocusCmd procedure, -force option} {
  162.     list [catch {focus -force a b} msg] $msg
  163. } {1 {wrong # args: should be "focus -force window"}}
  164. test focus-1.17 {Tk_FocusCmd procedure, -force option} {
  165.     list [catch {focus -force foo} msg] $msg
  166. } {1 {bad window path name "foo"}}
  167. test focus-1.18 {Tk_FocusCmd procedure, -force option} {
  168.     list [catch {focus -force ""} msg] $msg
  169. } {0 {}}
  170. test focus-1.19 {Tk_FocusCmd procedure, -force option} {
  171.     focusClear
  172.     focus .t.b1
  173.     set x  [list [focus]]
  174.     focus -force .t.b1
  175.     lappend x [focus]
  176. } {{} .t.b1}
  177. test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} {
  178.     list [catch {focus -lastfor} msg] $msg
  179. } {1 {wrong # args: should be "focus -lastfor window"}}
  180. test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} {
  181.     list [catch {focus -lastfor 1 2} msg] $msg
  182. } {1 {wrong # args: should be "focus -lastfor window"}}
  183. test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} {
  184.     list [catch {focus -lastfor who_knows?} msg] $msg
  185. } {1 {bad window path name "who_knows?"}}
  186. test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} {
  187.     focus .b
  188.     focus .t.b1
  189.     list [focus -lastfor .] [focus -lastfor .t.b3]
  190. } {.b .t.b1}
  191. test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} {
  192.     destroy .t
  193.     focusSetup
  194.     update
  195.     focus -lastfor .t.b2
  196. } {.t}
  197. test focus-1.25 {Tk_FocusCmd procedure} {
  198.     list [catch {focus -unknown} msg] $msg
  199. } {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}}
  200.  
  201. if $gotTestEvent {
  202.     test focus-2.1 {TkFocusFilterEvent procedure} {
  203.     focus -force .b
  204.     destroy .t
  205.     focusSetup
  206.     update
  207.     set focusInfo {}
  208.     testevent .t FocusIn -detail NotifyAncestor -sendevent 0x54217567
  209.     list $focusInfo
  210.     } {{}}
  211.     test focus-2.2 {TkFocusFilterEvent procedure} {
  212.     focus -force .b
  213.     destroy .t
  214.     focusSetup
  215.     update
  216.     set focusInfo {}
  217.     testevent .t FocusIn -detail NotifyAncestor -sendevent 0x547321ac
  218.     list $focusInfo [focus]
  219.     } {{in .t NotifyAncestor
  220. } .b}
  221.     test focus-2.3 {TkFocusFilterEvent procedure} {
  222.     focus -force .b
  223.     destroy .t
  224.     focusSetup
  225.     update
  226.     set focusInfo {}
  227.     testevent .t FocusIn -detail NotifyAncestor
  228.     update
  229.     list $focusInfo [focus -lastfor .t]
  230.     } {{out .b NotifyNonlinear
  231. out . NotifyNonlinearVirtual
  232. in .t NotifyNonlinear
  233. } .t}
  234.     test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} {
  235.     set result {}
  236.     focus .t.b1
  237.     foreach detail {NotifyAncestor NotifyNonlinear
  238.         NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot
  239.         NotifyVirtual} {
  240.         focus -force .
  241.         update
  242.         testevent .t FocusIn -detail $detail
  243.         set focusInfo {}
  244.         update
  245.         lappend result $focusInfo
  246.     }
  247.     set result
  248.     } {{out . NotifyNonlinear
  249. in .t NotifyNonlinearVirtual
  250. in .t.b1 NotifyNonlinear
  251. } {out . NotifyNonlinear
  252. in .t NotifyNonlinearVirtual
  253. in .t.b1 NotifyNonlinear
  254. } {out . NotifyNonlinear
  255. in .t NotifyNonlinearVirtual
  256. in .t.b1 NotifyNonlinear
  257. } {} {} {out . NotifyNonlinear
  258. in .t NotifyNonlinearVirtual
  259. in .t.b1 NotifyNonlinear
  260. }}
  261.     test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} {
  262.     destroy .t
  263.     focusSetup
  264.     update
  265.     testevent .t FocusIn -detail NotifyAncestor
  266.     list $focusInfo [focus]
  267.     } {{out . NotifyNonlinear
  268. in .t NotifyNonlinearVirtual
  269. in .t.b1 NotifyNonlinear
  270. } .t}
  271.     test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} {
  272.     focus .t.b1
  273.     focus .
  274.     update
  275.     testevent .t FocusIn -detail NotifyAncestor
  276.     set focusInfo {}
  277.     set x [focus]
  278.     testevent . KeyPress -keysym x
  279.     list $x $focusInfo
  280.     } {.t.b1 {press .t.b1 x}}
  281.     test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} {
  282.     set result {}
  283.     foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear
  284.         NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot
  285.         NotifyVirtual} {
  286.         focus -force .t.b1
  287.         testevent .t FocusOut -detail $detail
  288.         update
  289.         lappend result [focus]
  290.     }
  291.     set result
  292.     } {{} .t.b1 {} {} .t.b1 .t.b1 {}}
  293.     test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} {
  294.     focus -force .t.b1
  295.     testevent .t.b1 FocusOut -detail NotifyAncestor
  296.     focus
  297.     } {.t.b1}
  298.     test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} {
  299.     focus .t.b1
  300.     testevent . FocusOut -detail NotifyAncestor
  301.     focus
  302.     } {}
  303.     test focus-2.10 {TkFocusFilterEvent procedure, Enter events} {
  304.     set result {}
  305.     focus .t.b1
  306.     focusClear
  307.     foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear
  308.         NotifyNonlinearVirtual NotifyVirtual} {
  309.         testevent .t Enter -detail $detail -focus 1
  310.         update
  311.         lappend result [focus]
  312.         testevent .t Leave -detail NotifyAncestor
  313.     }
  314.     set result
  315.     } {.t.b1 {} .t.b1 .t.b1 .t.b1}
  316.     test focus-2.11 {TkFocusFilterEvent procedure, Enter events} {
  317.     focusClear
  318.     set focusInfo {}
  319.     testevent .t Enter -detail NotifyAncestor
  320.     update
  321.     set focusInfo
  322.     } {}
  323.     test focus-2.12 {TkFocusFilterEvent procedure, Enter events} {
  324.     focus -force .b
  325.     update
  326.     set focusInfo {}
  327.     testevent .t Enter -detail NotifyAncestor -focus 1
  328.     update
  329.     set focusInfo
  330.     } {}
  331.     test focus-2.13 {TkFocusFilterEvent procedure, Enter events} {
  332.     focus .t.b1
  333.     focusClear
  334.     testevent .t Enter -detail NotifyAncestor -focus 1
  335.     set focusInfo {}
  336.     update
  337.     set focusInfo
  338.     } {in .t NotifyVirtual
  339. in .t.b1 NotifyAncestor
  340. }
  341.     test focus-2.14 {TkFocusFilterEvent procedure, Leave events} {
  342.     set result {}
  343.     focus .t.b1
  344.     foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear
  345.         NotifyNonlinearVirtual NotifyVirtual} {
  346.         focusClear
  347.         testevent .t Enter -detail NotifyAncestor -focus 1
  348.         update
  349.         testevent .t Leave -detail $detail
  350.         update
  351.         lappend result [focus]
  352.     }
  353.     set result
  354.     } {{} .t.b1 {} {} {}}
  355.     test focus-2.15 {TkFocusFilterEvent procedure, Leave events} {
  356.     set result {}
  357.     focus .t.b1
  358.     testevent .t Enter -detail NotifyAncestor -focus 1
  359.     update
  360.     set focusInfo {}
  361.     testevent .t Leave -detail NotifyAncestor
  362.     update
  363.     set focusInfo
  364.     } {out .t.b1 NotifyAncestor
  365. out .t NotifyVirtual
  366. }
  367.     test focus-2.16 {TkFocusFilterEvent procedure, Leave events} {
  368.     set result {}
  369.     focus .t.b1
  370.     testevent .t Enter -detail NotifyAncestor -focus 1
  371.     update
  372.     set focusInfo {}
  373.     testevent .t.b1 Leave -detail NotifyAncestor
  374.     testevent . Leave -detail NotifyAncestor
  375.     update
  376.     list $focusInfo [focus]
  377.     } {{} .t.b1}
  378. }
  379.  
  380. test focus-3.1 {SetFocus procedure, create record on focus} {
  381.     toplevel .t2 -width 250 -height 100
  382.     wm geometry .t2 +0+0
  383.     update
  384.     focus -force .t2
  385.     update
  386.     focus
  387. } {.t2}
  388. catch {destroy .t2}
  389. # This test produces no result, but it will generate a protocol
  390. # error if Tk forgets to make the window exist before focussing
  391. # on it.
  392. test focus-3.2 {SetFocus procedure, making window exist} {
  393.     update
  394.     button .b2 -text "Another button"
  395.     focus .b2
  396.     update
  397. } {}
  398. catch {destroy .b2}
  399. update
  400. # The following test doesn't produce a check-able result, but if
  401. # there are bugs it may generate an X protocol error.
  402. test focus-3.3 {SetFocus procedure, delaying claim of X focus} {
  403.     focusSetup
  404.     focus -force .t.b2
  405.     update
  406. } {}
  407. test focus-3.4 {SetFocus procedure, delaying claim of X focus} {
  408.     focusSetup
  409.     wm withdraw .t
  410.     focus -force .t.b2
  411.     toplevel .t2 -width 250 -height 100
  412.     wm geometry .t2 +10+10
  413.     focus -force .t2
  414.     wm withdraw .t2
  415.     update
  416.     wm deiconify .t2
  417.     wm deiconify .t
  418. } {}
  419. catch {destroy .t2}
  420. test focus-3.5 {SetFocus procedure, generating events} {
  421.     focusClear
  422.     focusSetup
  423.     set focusInfo {}
  424.     focus -force .t.b2
  425.     update
  426.     set focusInfo
  427. } {in .t NotifyVirtual
  428. in .t.b2 NotifyAncestor
  429. }
  430. test focus-3.6 {SetFocus procedure, generating events} {
  431.     focus -force .b
  432.     update
  433.     focusSetup
  434.     set focusInfo {}
  435.     focus .t.b2
  436.     update
  437.     set focusInfo
  438. } {out .b NotifyNonlinear
  439. out . NotifyNonlinearVirtual
  440. in .t NotifyNonlinearVirtual
  441. in .t.b2 NotifyNonlinear
  442. out .t.b2 NotifyAncestor
  443. out .t NotifyVirtual
  444. in .t NotifyVirtual
  445. in .t.b2 NotifyAncestor
  446. }
  447. test focus-3.7 {SetFocus procedure, generating events} {
  448.     focusClear
  449.     focusSetup
  450.     set focusInfo {}
  451.     focus .t.b2
  452.     update
  453.     set focusInfo
  454. } {}
  455.  
  456. test focus-4.1 {TkFocusDeadWindow procedure} {
  457.     focusSetup
  458.     update
  459.     focus -force .b
  460.     update
  461.     destroy .t
  462.     focus
  463. } {.b}
  464. test focus-4.2 {TkFocusDeadWindow procedure} {
  465.     focusSetup
  466.     update
  467.     focus -force .t.b2
  468.     focus .b
  469.     update
  470.     destroy .t.b2
  471.     update
  472.     focus
  473. } {.b}
  474.  
  475. # Non-portable due to wm-specific redirection of input focus when
  476. # windows are deleted:
  477.  
  478. if $doNonPortableTests {
  479.     test focus-4.3 {TkFocusDeadWindow procedure} {
  480.     focusSetup
  481.     update
  482.     focus .t
  483.     update
  484.     destroy .t
  485.     update
  486.     focus
  487.     } {}
  488. }
  489. test focus-4.4 {TkFocusDeadWindow procedure} {
  490.     focusSetup
  491.     focus -force .t.b2
  492.     update
  493.     destroy .t.b2
  494.     focus
  495. } {.t}
  496.  
  497. # I don't know how to test the remaining procedures of this file
  498. # explicitly;  they've already been exercised by the preceding
  499. # tests.
  500.  
  501. catch {destroy .t}
  502. bind all <FocusIn> {}
  503. bind all <FocusOut> {}
  504. bind all <KeyPress> {}
  505. cleanupbg
  506.